{-# OPTIONS_GHC -XFlexibleInstances #-}
module XI.Directory.WS.Xmlable where 

import Data.List
import Text.XML.Light.Types
import Text.XML.Light.Proc
import Data.Time.LocalTime
import Data.Time.Format
import System.Locale
import Data.Time.Calendar
import Data.Typeable
import Data.Maybe
import Data.Data
import Control.Arrow
import Control.Concurrent.MVar
import qualified Data.Map as Map


data WsParams = WsParams {
		wspServer :: String,
		wspProtocolStr :: String,
		wspAuthorization :: Maybe String,
		wspLog :: Maybe String,
		wspProxy :: Maybe String,
		wspLogMVar :: MVar (),
		wspProxyMVar :: MVar (Maybe (Map.Map String String))
	}
	
instance Typeable LocalTime where
	typeOf lt = mkTyConApp (mkTyCon "LocalTime") []

class Xmlable a where
	toContent :: a -> [[Content]]
	fromContent :: [[Content]] -> a

instance Xmlable Char where
	toContent c = []
	fromContent cs = ' '
	
instance Xmlable LocalTime where
	toContent t = [[Text $ CData CDataText (formatTime defaultTimeLocale "%FT%X" t) Nothing]]
	fromContent [[Text (CData CDataText s _)]] = readTime defaultTimeLocale "%FT%T" $ fst.break (=='.') $ s

instance (Xmlable a) => Xmlable (Maybe a) where
	toContent Nothing = []
	toContent (Just x) = toContent x
	fromContent [] = Nothing
	fromContent [[]] = Nothing
	fromContent cs = Just (fromContent cs)

instance (Xmlable a, Typeable a) => Xmlable [a] where
	toContent [] = []
	toContent s = if show (typeOf s) == "[Char]" then [[Text $ CData CDataText (fromMaybe "" $ cast s) Nothing]] else concat $ map toContent s
	fromContent [] = []
	fromContent [[]] = []
	fromContent cs = case cs of 
		[[Text (CData CDataText s _)]] -> fromMaybe [] $ cast s
		otherwise -> map (\x->fromContent [x]) cs

makeToContent :: (Xmlable t) => [String] -> [t -> [[Content]]] -> t -> [Content]
makeToContent ss gs x = makeToContent' (zip ss gs) x
	where
		makeToContent' [] _ = []
		makeToContent' ((n, g):xs) x = [Elem $ blank_element { elName = blank_name { qName = n }, elContent = c } | c <- g x] ++ (makeToContent' xs x)

forFromContent :: [(String, String)] -> [String] -> [[Content]] -> [[[Content]]]
forFromContent nss ss = (pairs ss).(groupBy eqName).changePrefixInContents
	where
		changePrefixInContents = changePrefixInElems.onlyElems.head
		changePrefixInElems = map (\e -> e { elName = (elName e) { qPrefix = qURI (elName e) >>= flip find nss . (snd >>>) . (==) >>= return . fst } })
		pairs names [] = map (const []) names
		pairs (n:ns) ccs@(c:cs) = if nam (head c) == prefName n then (map elContent c):(pairs ns cs) else []:(pairs ns ccs)
		pairs names ccs = error ("Invalid pairs parameters: \n" ++ show names ++ "\n" ++ (show ccs))
		prefName = break (==':') >>> id *** tail
		nam = elName >>> (qPrefix >>> fromMaybe "") &&& qName
		eqName a b = nam a == nam b

